home *** CD-ROM | disk | FTP | other *** search
/ Dream 55 / Amiga_Dream_55.iso / RISCOS / APPS / TEXT / PS / KIT-PS.ZIP / Kit PS / !PSUtils / pl / extractres next >
Text File  |  1997-01-24  |  3KB  |  104 lines
  1. @rem = '-*- Perl -*-
  2. @echo off
  3. perl -S %0.cmd %1 %2 %3 %4 %5 %6 %7 %8 %9
  4. goto endofperl
  5. ';
  6.  
  7. # extractres: extract resources from PostScript file
  8. #
  9. # Copyright (C) Angus J. C. Duggan 1991-1995
  10. # See file LICENSE for details.
  11.  
  12. $prog = ($0 =~ s=.*/==);
  13.  
  14. %resources = ();        # list of resources included
  15. %merge = ();            # list of resources extracted this time
  16. %extn = ("font", ".pfa", "file", ".ps", "procset", ".ps", # resource extns
  17.      "pattern", ".pat", "form", ".frm", "encoding", ".enc");
  18. %type = ("%%BeginFile:", "file", "%%BeginProcSet:", "procset",
  19.      "%%BeginFont:", "font"); # resource types
  20.  
  21. while (@ARGV) {
  22.    $_ = shift;
  23.    if (/^-m(erge)?$/) { $merge = 1; }
  24.    elsif (/^-/) {
  25.       print STDERR "Usage: $prog [-merge] [file]\n";
  26.       exit 1;
  27.    } else {
  28.       unshift(@ARGV, $_);
  29.       last;
  30.    }
  31. }
  32.  
  33. if (defined($ENV{TMPDIR})) {    # set body file name
  34.    $body = "$ENV{TMPDIR}.body$$/ps";
  35. } else {
  36.    $body = "body$$/ps";
  37. }
  38.  
  39. open(BODY, $body) && die "Temporary file $body already exists";
  40. open(BODY, ">$body") || die "Can't write file $body";
  41.  
  42. sub filename {            # make filename for resource in @_
  43.    local($name);
  44.    foreach (@_) {        # sanitise name
  45.       s/[!()\$\#*&\\\|\`\'\"\~\{\}\[\]\<\>\?]//g;
  46.       $name .= $_;
  47.    }
  48.    $name =~ s@.*/@@;        # drop directories
  49.    die "Filename not found for resource ", join(" ", @_), "\n"
  50.       if $name =~ /^$/;
  51.    $name;
  52. }
  53.  
  54. $output = STDOUT;        # start writing header out
  55. while (<>) {
  56.    if (/^%%BeginResource:/ || /^%%BeginFont:/ || /^%%BeginProcSet:/) {
  57.       local($comment, @res) = split(/\s+/); # look at resource type
  58.       local($type) = defined($type{$comment}) ? $type{$comment} : shift(@res);
  59.       local($name) = &filename(@res, $extn{$type}); # make file name
  60.       $saveout = $output;
  61.       if (!$resources{$name}) {
  62.      print "%%IncludeResource: $type ", join(" ", @res), "\n";
  63.      if (!open(RES, $name)) {
  64.         open(RES, ">$name") || die "Can't write file $name";
  65.         $resources{$name} = $name;
  66.         $merge{$name} = $merge;
  67.         $output = RES;
  68.      } else {        # resource already exists
  69.         close(RES);
  70.         undef $output;
  71.      }
  72.       } elsif ($merge{$name}) {
  73.      open(RES, ">>$name") || die "Can't append to file $name";
  74.      $output = RES;
  75.       } else {            # resource already included
  76.      undef $output;
  77.       }
  78.    } elsif (/^%%EndResource/ || /^%%EndFont/ || /^%%EndProcSet/) {
  79.       if (defined $output) {
  80.      print $output $_;
  81.      close($output);
  82.       }
  83.       $output = $saveout;
  84.       next;
  85.    } elsif ((/^%%EndProlog/ || /^%%BeginSetup/ || /^%%Page:/)) {
  86.       $output = BODY;
  87.    }
  88.    print $output $_
  89.       if defined $output;
  90. }
  91.  
  92. close(BODY);            # close body output file
  93.  
  94. open(BODY, $body);        # reopen body for input
  95. while (<BODY>) {        # print it all
  96.    print $_;
  97. }
  98. close(BODY);
  99.  
  100. unlink($body);            # dispose of body file
  101. __END__
  102. :endofperl
  103.  
  104.